Collection of Tools & Utilities/Collection of Tools and Utilities.iso/sound/sample20.zip/RM.PAS

Pascal/Delphi Source File | 1989-03-28 | 39KB | 1,208 lines

{  Rowan McKenzie's personalised functions for Turbo Pascal 4  28/3/89}

Unit rm;

  {$v-}

  {************************************************************************}

Interface

Uses crt, graph, mousfunc, printer;


Const
  dialogstringlength = 100;
  clickboxstringlength = 100;

Type
  argtypes       = (_none, _boolean, _char, _integer, _real, _string);
  dialogentryp   = ^dialogentrytype;
  dialogentrytype = Record
                      next           : dialogentryp;
                      title          : String[dialogstringlength];
                      Case argtype   : argtypes Of
                        _none          : ();
                        _boolean : (booleanresult : Boolean);
                        _char : (charresult : Char);
                        _integer : (integerresult : Integer);
                        _real : (realresult     : Real;
                                decimalp       : Integer);
                        _string : (stringresult   : String[dialogstringlength];
                                  ssize : Byte; nulvalid : Boolean);
                    End;
  titletype      = (_text, _figure);
  polypointp     = ^polypoint;
  polypoint = Record
                x, y           : Integer;
              End;
  clickboxtypep  = ^clickboxtype;
  clickboxtype = Record
                   next           : clickboxtypep;
                   x, y           : Integer; {box top left corner position}
                   Case ttype     : titletype Of
                     _text : (title : String[clickboxstringlength]);
                     _figure : (numpoints : Word; polypoints : polypointp;
                                fill           : Boolean);
                 End;

Var exitsave   : Pointer;
  showerrormessage : Boolean;


Procedure heaperrorinit;

  { initialised head error pointer to custom procedure}

Function log(a : Real)      : Real;

  { calculates log base 10 of a}

Procedure fixcursor;

  { restores correct cursor for Herc card}

Procedure readinteger(Var num : Integer);

{ readlns an integer from kbd. if enter or invalid entry is entered,
  leaves num unchanged}

Procedure readlongint(Var num : LongInt);

{ readlns a long integer from kbd. if enter or invalid entry is entered,
  leaves num unchanged}

Procedure readreal(Var num : Real);

{ readlns a real from kbd. if enter or invalid entry is entered,
  leaves num unchanged}

Procedure greadstring(Var s : String; fieldwidth : Integer);

  { readlns a string from kbd in graphics mode}

Procedure greadinteger(Var num : Integer);

{ readlns an integer from kbd in graphics mode. if enter or invalid entry is
  entered, leaves num unchanged}

Procedure greadlongint(Var num : LongInt);

{ readlns a long integer from kbd in graphics mode. if enter or invalid entry
  is entered, leaves num unchanged}

Procedure greadreal(Var num : Real);

{ readlns a real from kbd in graphics mode. if enter or invalid entry is
  entered, leaves num unchanged}

Procedure swapscreen;

  { change virtual graphics pages, saving current page to heap}

Procedure leavegraph;

  { return to text mode, but save screen on heap}

Procedure entergraph(graphmode : Integer);

  { return to graphics mode, restoring saved screen from heap}

Procedure screendump;

  { graphics hardware independant graphics screen dump}

Procedure add_dialogentry(Var dp, lastdialogentry,
                          dialogentryhead : dialogentryp);

  { appends dialog entry to list}

Procedure dialog_box(dialog : dialogentryp; bcolor, color : Integer;
                     continueprompt : Boolean);

{ draws arguments messages in dialog box, allows editing of fields,
  restores area under box}

Procedure dispose_dialog(Var dp : dialogentryp);

  { disposes of all entries in dialog list}

Procedure beep;

  { short beep on console }

Procedure selectcolor(color : Word);

  { calls setcolor with modified color value depending on available colors}

Procedure selectbcolor(color : Word);

Procedure selectfillstyle(pattern : Word; color : Word);

{ calls selectfillstyle with modified color value depending on available
  colors}

Procedure selectbfillstyle(pattern : Word; color : Word);

{ calls selectfillstyle with modified background color value depending on
  available colors}

Procedure fill_background(color, fillpattern, arcsize : Word);

  { fills background with color and rounds the corners}

Procedure panel(x, y : Integer; width, height, color : Word);

  { draws solid panel with center top at x,y, width by height}

Procedure add_clickboxentry(Var cp, lastclickbox, clickboxhead : clickboxtypep);

  { appends clickbox to list}

Procedure draw_clicklist(cp : clickboxtypep; x, y, bcolor, color : Integer);

  { draws list of click boxes at given offset}

Function click_selection(cp : clickboxtypep; x, y : Integer) : Integer;

  { tests whether mouse is over a click box and returns its number in the list}

Procedure dispose_clickboxlist(Var cp : clickboxtypep);

  { disposes of all entries in click box list}

Function continue_prompt(x, y, bcolor, color : Integer) : Char;

  { displays continue prompt and waits for button or key}

Procedure display_message(s : String; bcolor, color : Integer;
                          Var storagep : Pointer; show       : Boolean);

  { draws message in box at screen center (or restores screen if show=false)}



  {********************************************************************}

Implementation

Const
  screens        = 2;
  bigemptystring =
  '                                                                                                                       ';

Var scrnbufp   : Array[1..screens] Of Pointer;
                                  {points to graphics screen save areas}
  currentscreen  : Byte;          {virtual graphics screen currently active}
  firstget       : Array[1..screens] Of Boolean;
                                  {indicate first time screen is saved}
  firstput       : Array[1..screens] Of Boolean;
                                  {indicate first time screen is restored}
  i              : Integer;



  Function log(a : Real)      : Real;

    { calculates log base 10 of a}

  Begin
    log := 0.434294481*ln(a);
  End;


  Procedure fixcursor;

  Begin
    MemW[0:$460] := $0b0c;
  End;                            {fixcursor}


  {$f+}
  Procedure myexit; {$f-}

    { incase graphics mode, restore text screen before error message is given}

  Begin
    restorecrtmode;
    ExitProc := exitsave;
    If showerrormessage Then
      WriteLn('Exit due to internal error!');
  End;                            {myexit}


  {$f+} Function heapfunc(size : Word)   : Integer; {$f-}

    { called when heap error occurs}

  Begin
    heapfunc := 1;
    restorecrtmode;
    WriteLn;
    WriteLn;
    WriteLn('Insufficient memory - sorry.', ^g);
    WriteLn;
    Halt;
  End;                            {heapfunc}


  Procedure heaperrorinit;

    { initialised head error pointer to custom procedure}

  Begin
    HeapError := @heapfunc;
  End;                            {heaperrorinit}


  Procedure readinteger(Var num : Integer);

{ readlns an integer from kbd. if enter or invalid entry is entered,
  leaves num unchanged}

  Var st         : String;
    code           : Integer;
    number         : LongInt;

  Begin
    ReadLn(st);
    If st <> '' Then
    Begin
      Val(st, number, code);
      If (code = 0) And (number >= -MaxInt) And (number <= MaxInt) Then
        num := number;
    End;
  End;                            {readinteger}


  Procedure readlongint(Var num : LongInt);

{ readlns a long integer from kbd. if enter or invalid entry is entered,
  leaves num unchanged}

  Var st         : String;
    code           : Integer;
    number         : LongInt;

  Begin
    ReadLn(st);
    If st <> '' Then
    Begin
      Val(st, number, code);
      If code = 0 Then
        num := numb